Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue61/Clinic/Object Browser/PropertyHelper.pas

Pascal/Delphi Source File | 2000-03-29 | 5.4 KB | 170 lines

unit PropertyHelper;

{$ifdef Ver100} { Delphi 3.0x }
  {$define DelphiLessThan5}
{$endif}
{$ifdef Ver110} { C++ Builder 3.0x }
  {$define DelphiLessThan5}
{$endif}
{$ifdef Ver120} { Delphi 4.0x }
  {$define DelphiLessThan5}
{$endif}

interface

uses
  TypInfo, Forms;

function GetObjectProp(Instance: TObject; PropInfo: PPropInfo; MinClass: TClass): TObject;
procedure SetObjectProp(Instance: TObject; PropInfo: PPropInfo; Value: TObject);

function GetPropValue(Obj: TObject; PropInfo: PPropInfo): String;
procedure SetPropValue(Obj: TObject; PropInfo: PPropInfo; const PropValue: String);

function DisplayModalAndFree(Form: TCustomForm): TModalResult;

type
  { Set access to an integer }
  TIntegerSet = set of 0..SizeOf(Integer) * 8 - 1;

implementation

uses
  SysUtils, Graphics, Controls, Menus, Classes;

function GetObjectProp(Instance: TObject; PropInfo: PPropInfo; MinClass: TClass): TObject;
begin
  Result := TObject(GetOrdProp(Instance, PropInfo));
  if (Result <> nil) and
     (MinClass <> nil) and
     not (Result is MinClass) then
    Result := nil;
end;

procedure SetObjectProp(Instance: TObject; PropInfo: PPropInfo; Value: TObject);
begin
  if (Value is GetTypeData(PropInfo.PropType^).ClassType) or
     (Value = nil) then
    SetOrdProp(Instance, PropInfo, Integer(Value));
end;

function GetPropValue(Obj: TObject; PropInfo: PPropInfo): String;
var
  AMethod: TMethod;
  AnObject: TObject;
  IntegerSet: TIntegerSet;
  Loop: Integer;
begin
  if PropInfo <> nil then
  begin
    try
      case PropInfo.PropType^.Kind of
        tkInteger:
        begin
          if (PropInfo.Name = 'Color') or (Pos('Color', PropInfo.Name) > 0) then
            Result := ColorToString(TColor(GetOrdProp(Obj, PropInfo)))
          else
          if (PropInfo.Name = 'Cursor') or (PropInfo.Name = 'DragCursor') then
            Result := CursorToString(TCursor(GetOrdProp(Obj, PropInfo)))
          else
          if PropInfo.Name = 'ShortCut' then
            Result := ShortCutToText(GetOrdProp(Obj, PropInfo))
          else
            Result := IntToStr(GetOrdProp(Obj, PropInfo))
        end;
        tkChar, tkWChar: Result := Chr(GetOrdProp(Obj, PropInfo));
        tkSet:
        //Result := GetSetProp(Obj, PropInfo, True);
        begin
          Integer(IntegerSet) := GetOrdProp(Obj, PropInfo);
          Result := '';
          for Loop := 0 to SizeOf(Integer) * 8 - 1 do
            if Loop in IntegerSet then
            begin
              if Result <> '' then
                Result := Result + ',';
              Result := Result + GetEnumName(GetTypeData(PropInfo.PropType^).CompType^, Loop);
            end;
          Result := '[' + Result + ']';
        end;
        tkClass:
        begin
          AnObject := TObject(GetOrdProp(Obj, PropInfo));
          if Assigned(AnObject) and
             (AnObject is TComponent) and
             (TComponent(AnObject).Name <> '') then
            Result := TComponent(AnObject).Name
          else
            Result :=
              '(' + GetTypeData(PropInfo.PropType^)^.ClassType.ClassName + ')';
        end;
        tkEnumeration:
          Result :=
            GetEnumName(PropInfo.PropType^, GetOrdProp(Obj, PropInfo));
        tkFloat:
          Result :=
            FloatToStr(GetFloatProp(Obj, PropInfo));
        tkString, tkLString, tkWString:
          Result := GetStrProp(Obj, PropInfo);
        tkMethod:
        begin
          AMethod := GetMethodProp(Obj, PropInfo);
          if AMethod.Code = nil then
            Result := ''
          else
            //If the method was not published, it's name will
            //not be available, so get its address instead
            try
              Result :=
                (TObject(AMethod.Data) as TComponent).MethodName(AMethod.Code)
            except
              Result := Format('$%p', [AMethod.Code]);
            end
        end
      end
    except
      Result := '<Error>';
    end
  end
end;

procedure SetPropValue(Obj: TObject; PropInfo: PPropInfo; const PropValue: String);
begin
  case PropInfo.PropType^.Kind of
    tkInteger:
    begin
      if (PropInfo.Name = 'Color') or (Pos('Color', PropInfo.Name) > 0) then
        SetOrdProp(Obj, PropInfo, Integer(StringToColor(PropValue)))
      else
      if (PropInfo.Name = 'Cursor') or (PropInfo.Name = 'DragCursor') then
        SetOrdProp(Obj, PropInfo, Integer(StringToCursor(PropValue)))
      else
      if PropInfo.Name = 'ShortCut' then
        SetOrdProp(Obj, PropInfo, Integer(TextToShortCut(PropValue)))
      else
        SetOrdProp(Obj, PropInfo, StrToInt(PropValue))
    end;
    tkChar, tkWChar: SetOrdProp(Obj, PropInfo, StrToInt(PropValue));
  {$ifndef DelphiLessThan5}
    tkSet: SetSetProp(Obj, PropInfo, PropValue);
  {$endif}
    tkClass: raise EInvalidOperation.Create('Changing class type properties is not supported');
    tkEnumeration: SetOrdProp(Obj, PropInfo,
      GetEnumValue(PropInfo.PropType^, PropValue));
    tkFloat: SetFloatProp(Obj, PropInfo, StrToFloat(PropValue));
    tkString, tkLString, tkWString: SetStrProp(Obj, PropInfo, PropValue);
    tkMethod: raise EInvalidOperation.Create('Changing method type properties is not supported');
  end
end;

function DisplayModalAndFree(Form: TCustomForm): TModalResult;
begin
  try
    Result := Form.ShowModal
  finally
    Form.Free
  end
end;

end.